home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 24 / CU Amiga Magazine's Super CD-ROM 24 (1998)(EMAP Images)(GB)(Track 1 of 2)[!][issue 1998-07].iso / CUCD / Programming / SWI / source / dlldemo / plregtry.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-08-27  |  15.5 KB  |  603 lines
  1. /*  $Id: plregtry.c,v 1.1 1996/08/27 09:17:41 jan Exp $
  2.  
  3.     Copyright (c) 1996 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: SWI-Prolog access to the Windows registry
  8. */
  9.  
  10. #include <SWI-Prolog.h>
  11. #include <windows.h>
  12. #include <malloc.h>
  13.  
  14. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  15. This file serves two purposes. It  both   provides  a  reasonable set of
  16. examples for using the SWI-Prolog foreign (C) interface, and it provides
  17. access to the Win32 registry database.   The library(registry) uses this
  18. file to register .PL files  as  Prolog   SourceFiles  and  allow you for
  19. consulting and editing Prolog files  immediately   from  the  Windows 95
  20. explorer.
  21. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  22.  
  23. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  24. These atoms and functors (handles to   a  name/arity identifier are used
  25. throughout the code. We look them up at initialisation and store them in
  26. global variables. Though this  module  isn't   very  time  critical,  in
  27. general it provides an enormous  speedup   to  avoid excessive lookup of
  28. atoms and functors.
  29. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  30.  
  31. static atom_t ATOM_classes_root;
  32. static atom_t ATOM_current_user;
  33. static atom_t ATOM_local_machine;
  34. static atom_t ATOM_users;
  35. static atom_t ATOM_all_access;
  36. static atom_t ATOM_create_link;
  37. static atom_t ATOM_create_sub_key;
  38. static atom_t ATOM_enumerate_sub_keys;
  39. static atom_t ATOM_execute;
  40. static atom_t ATOM_notify;
  41. static atom_t ATOM_query_value;
  42. static atom_t ATOM_read;
  43. static atom_t ATOM_set_value;
  44. static atom_t ATOM_write;
  45. static atom_t ATOM_volatile;
  46.  
  47. static functor_t FUNCTOR_binary1;
  48. static functor_t FUNCTOR_link1;
  49. static functor_t FUNCTOR_expand1;
  50.  
  51. static void
  52. init_constants()
  53. { ATOM_classes_root      = PL_new_atom("classes_root");
  54.   ATOM_current_user      = PL_new_atom("current_user");
  55.   ATOM_local_machine      = PL_new_atom("local_machine");
  56.   ATOM_users          = PL_new_atom("users");
  57.   ATOM_all_access      = PL_new_atom("all_access");
  58.   ATOM_create_link      = PL_new_atom("create_link");
  59.   ATOM_create_sub_key      = PL_new_atom("create_sub_key");
  60.   ATOM_enumerate_sub_keys = PL_new_atom("enumerate_sub_keys");
  61.   ATOM_execute          = PL_new_atom("execute");
  62.   ATOM_notify          = PL_new_atom("notify");
  63.   ATOM_query_value      = PL_new_atom("query_value");
  64.   ATOM_read          = PL_new_atom("read");
  65.   ATOM_set_value      = PL_new_atom("set_value");
  66.   ATOM_write          = PL_new_atom("write");
  67.   ATOM_volatile          = PL_new_atom("volatile");
  68.  
  69.   FUNCTOR_binary1      = PL_new_functor(PL_new_atom("binary"), 1);
  70.   FUNCTOR_link1          = PL_new_functor(PL_new_atom("link"), 1);
  71.   FUNCTOR_expand1      = PL_new_functor(PL_new_atom("expand"), 1);
  72. }
  73.  
  74.  
  75. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  76. Just a function to translate  a  Windows   error  code  to a message. It
  77. exploits the static nature of  Prolog   atoms  to avoid storing multiple
  78. copies of the same message.
  79. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  80.  
  81. static const char *
  82. APIError(DWORD id)
  83. { char *msg;
  84.   static WORD lang;
  85.   static lang_initialised = 0;
  86.  
  87.   if ( !lang_initialised )
  88.     lang = MAKELANGID(LANG_ENGLISH, SUBLANG_ENGLISH_UK);
  89.  
  90. again:
  91.   if ( FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER|
  92.              FORMAT_MESSAGE_IGNORE_INSERTS|
  93.              FORMAT_MESSAGE_FROM_SYSTEM,
  94.              NULL,            /* source */
  95.              id,            /* identifier */
  96.              lang,
  97.              (LPTSTR) &msg,
  98.              0,                /* size */
  99.              NULL) )            /* arguments */
  100.   { atom_t a = PL_new_atom(msg);
  101.  
  102.     LocalFree(msg);
  103.     lang_initialised = 1;
  104.  
  105.     return PL_atom_chars(a);
  106.   } else
  107.   { if ( lang_initialised == 0 )
  108.     { lang = MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT);
  109.       lang_initialised = 1;
  110.       goto again;
  111.     }
  112.  
  113.     return "Unknown Windows error";
  114.   }
  115. }
  116.  
  117.  
  118. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  119. Translate a term, that  is  either  an   atom,  indicating  one  of  the
  120. predefined roots of the registry, or an integer that is an open registry
  121. handle. Integers are 32-bit wide, so it is generally ok to store handles
  122. in  Prolog  integers.  Note   however    that   Prolog   integers  above
  123. max_tagged_integer require considerably more space.
  124. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  125.  
  126. static HKEY
  127. to_key(term_t h)
  128. { atom_t n;
  129.   int k;
  130.  
  131.   if ( PL_get_atom(h, &n) )        /* named key */
  132.   { if ( n == ATOM_classes_root )
  133.       return HKEY_CLASSES_ROOT;
  134.     if ( n == ATOM_current_user )
  135.       return HKEY_CURRENT_USER;
  136.     if ( n == ATOM_local_machine )
  137.       return HKEY_LOCAL_MACHINE;
  138.     if ( n == ATOM_users )
  139.       return HKEY_USERS;
  140.   }
  141.  
  142.   if ( PL_get_integer(h, &k) )
  143.     return (HKEY)k;            /* integer key */
  144.  
  145.   return 0;                /* invalid key */
  146. }
  147.  
  148.  
  149. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  150. reg_subkeys(+Super, -Subs)
  151.     Return list of keys below Super.  The list of keys is of the
  152.     form key(KeyName, KeyClass).
  153.  
  154. ****
  155.  
  156. This predicate illustrates  returning  a  list   of  atoms.  First,  the
  157. argument reference is copied into  the   `tail'  reference.  This is not
  158. strictly necessary, but if you don't  do   this,  the tracer will always
  159. think this predicate succeeded with the empty list. `head' is just a new
  160. term reference, used for handling the various cells.
  161. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  162.  
  163. foreign_t
  164. pl_reg_subkeys(term_t h, term_t l)
  165. { HKEY k = to_key(h);
  166.   int i;
  167.   term_t tail = PL_copy_term_ref(l);
  168.   term_t head = PL_new_term_ref();
  169.  
  170.   if ( !k )
  171.     PL_fail;
  172.  
  173.   for(i=0;;i++)
  174.   { long rval;
  175.     char kname[256];
  176.     int  sk = sizeof(kname);
  177.     char cname[256];
  178.     int  sc = sizeof(cname);
  179.     FILETIME t;
  180.  
  181.     rval = RegEnumKeyEx(k, i, kname, &sk, NULL, cname, &sc, &t);
  182.     if ( rval == ERROR_SUCCESS )
  183.     { if ( PL_unify_list(tail, head, tail) &&
  184.        PL_unify_atom_chars(head, kname) )
  185.     continue;
  186.       else
  187.     PL_fail;            /* close key? */
  188.     } else if ( rval == ERROR_NO_MORE_ITEMS )
  189.     { return PL_unify_nil(tail);
  190.     } else
  191.     { return PL_warning("reg_subkeys/2: %s", APIError(rval));
  192.     }
  193.   }
  194. }
  195.  
  196.  
  197. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  198. Maybe better in a table ...
  199. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  200.  
  201. static REGSAM
  202. access_code(atom_t name)
  203. { if ( name == ATOM_all_access )
  204.     return KEY_ALL_ACCESS;
  205.   if ( name == ATOM_create_link )
  206.     return KEY_CREATE_LINK;
  207.   if ( name == ATOM_create_sub_key )
  208.     return KEY_CREATE_SUB_KEY;
  209.   if ( name == ATOM_enumerate_sub_keys )
  210.     return KEY_ENUMERATE_SUB_KEYS;
  211.   if ( name == ATOM_execute )
  212.     return KEY_EXECUTE;
  213.   if ( name == ATOM_notify )
  214.     return KEY_NOTIFY;
  215.   if ( name == ATOM_query_value )
  216.     return KEY_QUERY_VALUE;
  217.   if ( name == ATOM_read )
  218.     return KEY_READ;
  219.   if ( name == ATOM_set_value )
  220.     return KEY_SET_VALUE;
  221.   if ( name == ATOM_write )
  222.     return KEY_WRITE;
  223.  
  224.   return 0;                /* bad key */
  225. }
  226.  
  227.  
  228. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  229. Read a list. Instead of PL_unify_list(),  this uses PL_get_list(), which
  230. fails if the argument is not instantiated to a list.
  231. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  232.  
  233. static int
  234. get_access(term_t access, REGSAM *mode)
  235. { atom_t a;
  236.  
  237.   if ( PL_get_atom(access, &a) )
  238.     *mode = access_code(a);
  239.   else
  240.   { term_t tail = PL_copy_term_ref(access);
  241.     term_t head = PL_new_term_ref();
  242.  
  243.     *mode = 0;
  244.     while(PL_get_list(tail, head, tail))
  245.     { if ( PL_get_atom(head, &a) )
  246.     *mode |= access_code(a);
  247.       else
  248.     return FALSE;
  249.     }
  250.     if ( !PL_get_nil(tail) )
  251.       return FALSE;
  252.   }
  253.  
  254.   return TRUE;
  255. }
  256.  
  257.  
  258. foreign_t
  259. pl_reg_open_key(term_t parent, term_t name, term_t access, term_t handle)
  260. { HKEY kp;
  261.   char *s;
  262.   REGSAM mode;
  263.   HKEY rk;
  264.   long rval;
  265.  
  266.   if ( !(kp = to_key(parent)) ||
  267.        !PL_get_atom_chars(name, &s) ||
  268.        !get_access(access, &mode) )
  269.     PL_fail;
  270.  
  271.   rval = RegOpenKeyEx(kp, s, 0L, mode, &rk);
  272.   if ( rval == ERROR_SUCCESS )
  273.     return PL_unify_integer(handle, (int)rk);
  274.   if ( rval == ERROR_FILE_NOT_FOUND )
  275.     PL_fail;
  276.  
  277.   return PL_warning("reg_open_key/4: (%d), %s", rval, APIError(rval));
  278. }
  279.  
  280.  
  281. foreign_t
  282. pl_reg_close_key(term_t h)
  283. { HKEY k;
  284.  
  285.   if ( PL_is_integer(h) && (k = to_key(h)) )
  286.   { RegCloseKey(k);
  287.   }
  288.  
  289.   PL_succeed;
  290. }
  291.  
  292.  
  293. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  294. reg_delete_key(+ParentHandle, +Name)
  295.     Delete key from parent.
  296. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  297.  
  298. foreign_t
  299. pl_reg_delete_key(term_t h, term_t sub)
  300. { HKEY k;
  301.   char *s;
  302.   DWORD rval;
  303.  
  304.   if ( !(k = to_key(h)) ||
  305.        !PL_get_atom_chars(sub, &s) )
  306.     PL_fail;
  307.  
  308.   if ( (rval = RegDeleteKey(k, s)) == ERROR_SUCCESS )
  309.     PL_succeed;
  310.  
  311.   return PL_warning("reg_delete_key/2: %s", APIError(rval));
  312. }
  313.  
  314.          /*******************************
  315.          *           VALUE        *
  316.          *******************************/
  317.  
  318. foreign_t
  319. pl_reg_value_names(term_t h, term_t names)
  320. { HKEY k;
  321.   DWORD rval;
  322.   term_t tail = PL_copy_term_ref(names);
  323.   term_t head = PL_new_term_ref();
  324.   DWORD i;
  325.  
  326.   if ( !(k = to_key(h)) )
  327.     PL_fail;
  328.   
  329.   for(i=0;;i++)
  330.   { char name[256];
  331.     DWORD sizen = sizeof(name);
  332.  
  333.     rval = RegEnumValue(k, i, name, &sizen, NULL, NULL, NULL, NULL);
  334.     if ( rval == ERROR_SUCCESS )
  335.     { if ( PL_unify_list(tail, head, tail) &&
  336.        PL_unify_atom_chars(head, name) )
  337.     continue;
  338.     } else if ( rval == ERROR_NO_MORE_ITEMS )
  339.     { return PL_unify_nil(tail);
  340.     } else
  341.       return PL_warning("reg_value_names/2: %s", APIError(rval));
  342.   }
  343. }
  344.  
  345.  
  346. foreign_t
  347. pl_reg_value(term_t h, term_t name, term_t value)
  348. { HKEY k;
  349.   char *vname;
  350.   DWORD rval;
  351.   BYTE databuf[1024];
  352.   LPBYTE data = databuf;
  353.   DWORD sizedata = sizeof(databuf);
  354.   DWORD type;
  355.  
  356.   if ( !(k = to_key(h)) || !PL_get_atom_chars(name, &vname) )
  357.     PL_fail;
  358.  
  359.   rval = RegQueryValueEx(k, vname, NULL, &type, data, &sizedata);
  360.   if ( rval == ERROR_MORE_DATA )
  361.   { data = alloca(sizedata);
  362.     rval = RegQueryValueEx(k, vname, NULL, &type, data, &sizedata);
  363.   } 
  364.  
  365.   if ( rval == ERROR_SUCCESS )
  366.   { switch(type)
  367.     { case REG_BINARY:
  368.       { term_t head = PL_new_term_ref();
  369.     term_t tail = PL_new_term_ref();
  370.     
  371.     if ( PL_unify_term(value, PL_FUNCTOR, FUNCTOR_binary1,
  372.                        PL_TERM, tail) )
  373.     { DWORD i;
  374.  
  375.       for(i=0; i<sizedata; i++)
  376.       { if ( !PL_unify_list(tail, head, tail) ||
  377.          !PL_unify_integer(head, data[i]) )
  378.           PL_fail;
  379.       }
  380.  
  381.       return PL_unify_nil(tail);
  382.     }
  383.  
  384.     PL_fail;
  385.       }
  386.       { DWORD v;
  387.       case REG_DWORD_BIG_ENDIAN:
  388.       { DWORD v0 = *((DWORD *)data);
  389.  
  390.     v = ((v0 >>  0) % 0xff) << 24 |
  391.         ((v0 >>  8) % 0xff) << 16 |
  392.         ((v0 >> 16) % 0xff) <<  8 |
  393.         ((v0 >> 24) % 0xff) <<  0;
  394.     goto case_dword;
  395.       }
  396. /*    case REG_DWORD: */
  397.       case REG_DWORD_LITTLE_ENDIAN:
  398.     v = *((DWORD *)data);
  399.       case_dword:
  400.     return PL_unify_integer(value, v);
  401.       }
  402.       case REG_EXPAND_SZ:
  403.       { return PL_unify_term(value, PL_FUNCTOR, FUNCTOR_expand1,
  404.                          PL_CHARS, (char *)data);
  405.       }
  406.       case REG_LINK:
  407.       { return PL_unify_term(value, PL_FUNCTOR, FUNCTOR_link1,
  408.                          PL_CHARS, (char *)data);
  409.       }
  410.       case REG_MULTI_SZ:
  411.       { term_t tail = PL_copy_term_ref(value);
  412.     term_t head = PL_new_term_ref();
  413.     char *s = (char *)data;
  414.  
  415.     while(*s)
  416.     { if ( !PL_unify_list(tail, head, tail) ||
  417.            !PL_unify_atom_chars(head, s) )
  418.         PL_fail;
  419.  
  420.       s += strlen(s) + 1;
  421.     }
  422.  
  423.     return PL_unify_nil(tail);
  424.       }
  425.       case REG_NONE:
  426.     return PL_unify_atom_chars(value, "<none>");
  427.       case REG_RESOURCE_LIST:
  428.     return PL_unify_atom_chars(value, "<resource_list>");
  429.       case REG_SZ:
  430.     return PL_unify_atom_chars(value, (char *)data);
  431.     }
  432.   } else
  433.     return PL_warning("reg_value/3: %s", APIError(rval));
  434. }
  435.  
  436.  
  437. foreign_t
  438. pl_reg_set_value(term_t h, term_t name, term_t value)
  439. { HKEY k;
  440.   char *vname;
  441.   DWORD rval, type, len;
  442.   BYTE *data;
  443.  
  444.   if ( !(k = to_key(h)) || !PL_get_atom_chars(name, &vname) )
  445.     PL_fail;
  446.  
  447.   switch(PL_term_type(value))
  448.   { case PL_ATOM:
  449.       PL_get_atom_chars(value, &data);
  450.       len = strlen(data) + 1;
  451.       type = REG_SZ;
  452.       break;
  453.     case PL_STRING:
  454.       PL_get_string(value, &data, &len);
  455.       type = REG_SZ;
  456.       break;
  457.     case PL_INTEGER:
  458.     { DWORD i;
  459.       PL_get_long(value, &i);
  460.       data = (BYTE *) &i;
  461.       len = sizeof(i);
  462.       type = REG_DWORD;
  463.       break;
  464.     }
  465.     case PL_TERM:
  466.     { if ( PL_is_functor(value, FUNCTOR_link1) )
  467.       { type = REG_LINK;
  468.     goto argdata;
  469.       } else if ( PL_is_functor(value, FUNCTOR_expand1) )
  470.       { term_t a;
  471.  
  472.     type = REG_EXPAND_SZ;
  473.  
  474.       argdata:
  475.     a = PL_new_term_ref();
  476.     PL_get_arg(1, value, a);
  477.     if ( !PL_get_atom_chars(a, &data) )
  478.       goto error;
  479.     len = strlen(data) + 1;
  480.     break;
  481.       }                    /* TBD: MULTI_SZ (list) */
  482.     }
  483.     default:
  484.     error:
  485.       return PL_warning("reg_set_value/3: instantiation error");
  486.   }
  487.  
  488.  
  489.   rval = RegSetValueEx(k, vname, 0L, type, data, len);
  490.   if ( rval == ERROR_SUCCESS )
  491.     PL_succeed;
  492.  
  493.   return PL_warning("reg_set_value/3: %s", APIError(rval));
  494. }
  495.  
  496.  
  497. foreign_t
  498. pl_reg_delete_value(term_t h, term_t name)
  499. { HKEY k;
  500.   char *vname;
  501.   LONG rval;
  502.  
  503.   if ( !(k = to_key(h)) || !PL_get_atom_chars(name, &vname) )
  504.     PL_fail;
  505.   
  506.   if ( (rval = RegDeleteValue(k, vname)) == ERROR_SUCCESS )
  507.     PL_succeed;
  508.  
  509.   return PL_warning("reg_delete_value/2: %s", APIError(rval));
  510. }
  511.  
  512.  
  513.  
  514.  
  515. foreign_t
  516. pl_reg_flush(term_t h)
  517. { HKEY k;
  518.  
  519.   if ( (k = to_key(h)) )
  520.   { DWORD rval;
  521.     
  522.     if ( (rval = RegFlushKey(k)) == ERROR_SUCCESS )
  523.       PL_succeed;
  524.  
  525.     return PL_warning("reg_flush/1: %s", APIError(rval));
  526.   }
  527.  
  528.   PL_fail;
  529. }
  530.  
  531.  
  532. foreign_t
  533. pl_reg_create_key(term_t h, term_t name,
  534.           term_t class, term_t options, term_t access,
  535.           term_t key)
  536. { HKEY k, skey;
  537.   char *kname;                /* key-name */
  538.   char *cname;                /* class-name */
  539.   REGSAM mode;
  540.   DWORD ops = REG_OPTION_NON_VOLATILE;
  541.   term_t tail = PL_copy_term_ref(options);
  542.   term_t head = PL_new_term_ref();
  543.   DWORD rval;
  544.   DWORD disp;
  545.  
  546.   if ( !(k = to_key(h)) ||
  547.        !PL_get_atom_chars(name, &kname) ||
  548.        !PL_get_atom_chars(class, &cname) ||
  549.        !get_access(access, &mode) )
  550.     PL_fail;
  551.  
  552.   while(PL_get_list(tail, head, tail))
  553.   { atom_t a;
  554.  
  555.     if ( PL_get_atom(head, &a) )
  556.     { if ( a == ATOM_volatile )
  557.       {    ops &= ~REG_OPTION_NON_VOLATILE;
  558.     ops |= REG_OPTION_VOLATILE;
  559.     continue;
  560.       }
  561.     }
  562.  
  563.     PL_fail;
  564.   }
  565.   if ( !PL_get_nil(tail) )
  566.     PL_fail;
  567.  
  568.   rval = RegCreateKeyEx(k, kname, 0L, cname, ops, mode, NULL, &skey, &disp);
  569.   if ( rval == ERROR_SUCCESS )
  570.     return PL_unify_integer(key, (long)skey);
  571.   else
  572.     return PL_warning("reg_create_key/6: %s", APIError(rval));
  573. }
  574.  
  575.  
  576.          /*******************************
  577.          *          INSTALL        *
  578.          *******************************/
  579.  
  580. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  581. Finally, register the predicates.  Simply calling
  582.  
  583.     ?- load_foreign_library(plregtry).
  584.  
  585. will makes these available in the calling context module.
  586. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  587.  
  588. install_t
  589. install()
  590. { init_constants();
  591.  
  592.   PL_register_foreign("reg_subkeys",     2, pl_reg_subkeys,    0);
  593.   PL_register_foreign("reg_open_key",     4, pl_reg_open_key,    0);
  594.   PL_register_foreign("reg_close_key",     1, pl_reg_close_key,    0);
  595.   PL_register_foreign("reg_delete_key",     2, pl_reg_delete_key,    0);
  596.   PL_register_foreign("reg_value_names", 2, pl_reg_value_names, 0);
  597.   PL_register_foreign("reg_value",       3, pl_reg_value,       0);
  598.   PL_register_foreign("reg_set_value",   3, pl_reg_set_value,   0);
  599.   PL_register_foreign("reg_delete_value",2, pl_reg_delete_value,0);
  600.   PL_register_foreign("reg_flush",       1, pl_reg_flush,       0);
  601.   PL_register_foreign("reg_create_key",     6, pl_reg_create_key,    0);
  602. }
  603.